-- | SSL-enabled http transport with support for https requests and client certificates.

module Network.SOAP.Transport.HTTP.TLS
    ( confTransport
    , makeSettings
    -- * Certificate validation
    , ServerCertCallback, validateDefault
    ) where

import Network.HTTP.Client (ManagerSettings)
import Network.SOAP.Transport (Transport)
import Network.SOAP.Transport.HTTP (confTransportWith)

import Network.HTTP.Client.TLS
import Network.TLS
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation
import Network.Connection (TLSSettings(..))

import           Data.Text (Text)
import           Data.Default (def)
import qualified Data.Configurator as Conf
import           Data.Configurator.Types (Config)

type ServerCertCallback = CertificateStore
                       -> ValidationCache
                       -> ServiceID
                       -> CertificateChain
                       -> IO [FailedReason]

-- | Initialize a SOAP HTTP transport with HTTPS support using tls.
confTransport :: Text   -- ^ Section name containing transport settings.
              -> Config
              -> ServerCertCallback
              -> IO Transport
confTransport :: Name -> Config -> ServerCertCallback -> IO Transport
confTransport Name
section Config
conf ServerCertCallback
onSC = do
    Maybe FilePath
cert <- Config -> Name -> IO (Maybe FilePath)
forall a. Configured a => Config -> Name -> IO (Maybe a)
Conf.lookup Config
conf (Name
section Name -> Name -> Name
forall a. Monoid a => a -> a -> a
`mappend` Name
".client_cert")
    Maybe FilePath
key <- Config -> Name -> IO (Maybe FilePath)
forall a. Configured a => Config -> Name -> IO (Maybe a)
Conf.lookup Config
conf (Name
section Name -> Name -> Name
forall a. Monoid a => a -> a -> a
`mappend` Name
".client_key")
    ManagerSettings
settings <- Maybe FilePath
-> Maybe FilePath -> ServerCertCallback -> IO ManagerSettings
makeSettings Maybe FilePath
cert Maybe FilePath
key ServerCertCallback
onSC
    ManagerSettings
-> Name -> Config -> RequestP -> BodyP -> IO Transport
confTransportWith ManagerSettings
settings Name
section Config
conf RequestP
forall a. a -> a
id BodyP
forall a. a -> a
id

makeSettings :: Maybe FilePath
             -> Maybe FilePath
             -> ServerCertCallback
             -> IO ManagerSettings
makeSettings :: Maybe FilePath
-> Maybe FilePath -> ServerCertCallback -> IO ManagerSettings
makeSettings (Just FilePath
certFile) (Just FilePath
keyFile) ServerCertCallback
onSC = do
    Maybe Credential
creds <- (FilePath -> Maybe Credential)
-> (Credential -> Maybe Credential)
-> Either FilePath Credential
-> Maybe Credential
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Maybe Credential
forall a. HasCallStack => FilePath -> a
error Credential -> Maybe Credential
forall a. a -> Maybe a
Just (Either FilePath Credential -> Maybe Credential)
-> IO (Either FilePath Credential) -> IO (Maybe Credential)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> FilePath -> IO (Either FilePath Credential)
credentialLoadX509 FilePath
certFile FilePath
keyFile

    let onCR :: p -> m (Maybe Credential)
onCR p
_ = Maybe Credential -> m (Maybe Credential)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Credential
creds
    let hooks :: ClientHooks
hooks = ClientHooks
forall a. Default a => a
def { onCertificateRequest :: OnCertificateRequest
onCertificateRequest = OnCertificateRequest
forall {m :: * -> *} {p}. Monad m => p -> m (Maybe Credential)
onCR
                    , onServerCertificate :: ServerCertCallback
onServerCertificate  = ServerCertCallback
onSC
                    }
    let clientParams :: ClientParams
clientParams = (FilePath -> ByteString -> ClientParams
defaultParamsClient FilePath
"" ByteString
"") { clientHooks :: ClientHooks
clientHooks = ClientHooks
hooks }
    ManagerSettings -> IO ManagerSettings
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ManagerSettings -> IO ManagerSettings)
-> ManagerSettings -> IO ManagerSettings
forall a b. (a -> b) -> a -> b
$! TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings (ClientParams -> TLSSettings
TLSSettings ClientParams
clientParams) Maybe SockSettings
forall a. Maybe a
Nothing

makeSettings Maybe FilePath
_ Maybe FilePath
_ ServerCertCallback
_ = ManagerSettings -> IO ManagerSettings
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ManagerSettings
tlsManagerSettings