module Network.SOAP.Transport.HTTP.TLS
( confTransport
, makeSettings
, 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]
confTransport :: Text
-> Config
-> ServerCertCallback
-> IO Transport
confTransport :: Text -> Config -> ServerCertCallback -> IO Transport
confTransport Text
section Config
conf ServerCertCallback
onSC = do
Maybe FilePath
cert <- Config -> Text -> IO (Maybe FilePath)
forall a. Configured a => Config -> Text -> IO (Maybe a)
Conf.lookup Config
conf (Text
section Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
".client_cert")
Maybe FilePath
key <- Config -> Text -> IO (Maybe FilePath)
forall a. Configured a => Config -> Text -> IO (Maybe a)
Conf.lookup Config
conf (Text
section Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
".client_key")
ManagerSettings
settings <- Maybe FilePath
-> Maybe FilePath -> ServerCertCallback -> IO ManagerSettings
makeSettings Maybe FilePath
cert Maybe FilePath
key ServerCertCallback
onSC
ManagerSettings
-> Text -> Config -> RequestP -> BodyP -> IO Transport
confTransportWith ManagerSettings
settings Text
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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return ManagerSettings
tlsManagerSettings