TLSSetting.hs

{-# LANGUAGE CPP #-}

-- | Construct verified TLS parameters for MariaDB connections. Choose managed
-- OS roots or an application CA file and reuse parameters across connections.
-- The connection constructor supplies the certificate hostname/default SNI.
-- Customize cipher/credential policy through the @tls@ package when needed.
--
-- File/PEM/credential errors throw during parameter construction. These helpers
-- do not disable peer verification or make a plaintext connection secure.
--
module Data.TLSSetting
    ( -- * Choose a CAStore
      TrustedCAStore(..)
      -- * Make TLS settings
    , makeClientParams
    , makeClientParams'
    , makeServerParams
    , makeServerParams'
      -- * Internal
    , mozillaCAStorePath
    ) where

import           Control.Monad (when)
import qualified Data.ByteString            as B
import qualified Data.PEM                   as X509
import qualified Data.X509                  as X509
import qualified Data.X509.CertificateStore as X509
import qualified Network.TLS                as TLS
import qualified Network.TLS.Extra          as TLS
import           Paths_mariadb_haskell          (getDataFileName)
import qualified System.X509                as X509

#if !MIN_VERSION_tls(2,1,4)
import           Data.Default.Class         (def)
#endif

-- | Trust anchors used by the TLS verifier alongside hostname and certificate
-- checks. Prefer an OS/application-managed store with an explicit update policy.
data TrustedCAStore
    = SystemCAStore                   -- ^ Read the operating system's trust roots.
    | MozillaCAStore                  -- ^ Installed Mozilla snapshot; see docs/CA_BUNDLE.md for source, checksum and update policy.
    | CustomCAStore FilePath          -- ^ PEM CA file containing one or more certificates; malformed/empty files fail.
  deriving (Show, Eq)

-- | Resolve the installed bundle through Cabal's data directory, independent
-- of the working directory. This does not refresh or validate its contents.
mozillaCAStorePath :: IO FilePath
mozillaCAStorePath = getDataFileName "mozillaCAStore.pem"

makeCAStore :: TrustedCAStore -> IO X509.CertificateStore
makeCAStore SystemCAStore       = X509.getSystemCertificateStore
makeCAStore MozillaCAStore      = makeCAStore . CustomCAStore =<< mozillaCAStorePath
makeCAStore (CustomCAStore fp)  = do
    bs <- B.readFile fp
    pems <- either (ioError . userError) pure (X509.pemParseBS bs)
    when (null pems) (ioError (userError "CA file contains no certificates"))
    case mapM (X509.decodeSignedCertificate . X509.pemContent) pems of
        Right cas -> return (X509.makeCertificateStore cas)
        Left err  -> ioError (userError err)

-- | Verify server certificates using the selected roots, without supplying a
-- client certificate. The connection constructor later supplies the server
-- identity; pass its certificate DNS name rather than disabling verification.
-- Root loading happens here, so reuse the result in a connection factory.
--
makeClientParams :: TrustedCAStore          -- ^ trusted certificates.
                 -> IO TLS.ClientParams
makeClientParams tca = do
    caStore <- makeCAStore tca
    return (TLS.defaultParamsClient "" B.empty)
        {   TLS.clientSupported = defaultSupported' { TLS.supportedCiphers = TLS.ciphersuite_default }
        ,   TLS.clientShared    = defaultShared'
            {   TLS.sharedCAStore         = caStore
            ,   TLS.sharedValidationCache = defaultValidationCache'
            }
        }

-- | Verify the server and supply a client certificate/key for mutual TLS.
--
-- The helper installs the sole supplied credential in the certificate-request
-- hook; sharedCredentials alone does not answer a server's client-cert request.
-- Server identity is still verified against the supplied CA store.
--
makeClientParams' :: FilePath       -- ^ public certificate (X.509 format).
                  -> [FilePath]     -- ^ chain certificates (X.509 format).
                                    --   the root of your certificate chain should be
                                    --   already trusted by server, or tls will fail.
                  -> FilePath       -- ^ private key associated.
                  -> TrustedCAStore -- ^ trusted certificates.
                  -> IO TLS.ClientParams
makeClientParams' pub certs priv tca = do
    p <- makeClientParams tca
    c <- TLS.credentialLoadX509Chain pub certs priv
    case c of
        Right c' ->
            return p
                {   TLS.clientHooks = (TLS.clientHooks p)
                    { TLS.onCertificateRequest = \_ -> pure (Just c') }
                ,   TLS.clientShared = (TLS.clientShared p)
                    {
                        TLS.sharedCredentials = TLS.Credentials [c']
                    }
                }
        Left err -> ioError (userError err)

-- | Low-level TLS server helper retained for compatibility and transport tests.
-- Supplies a server credential without requesting a client certificate; it does
-- not implement a MariaDB server. Ordinary client applications use 'makeClientParams'.
--
makeServerParams :: FilePath        -- ^ public certificate (X.509 format).
                 -> [FilePath]      -- ^ chain certificates (X.509 format).
                                    --   the root of your certificate chain should be
                                    --   already trusted by client, or tls will fail.
                 -> FilePath        -- ^ private key associated.
                 -> IO TLS.ServerParams
makeServerParams pub certs priv = do
    c <- TLS.credentialLoadX509Chain pub certs priv
    case c of
        Right c'@(X509.CertificateChain c'', _) ->
            return defaultServerParams'
                {   TLS.serverCACertificates =  c''
                ,   TLS.serverShared = defaultShared'
                    {
                        TLS.sharedCredentials = TLS.Credentials [c']
                    }
                ,   TLS.serverSupported = defaultSupported' { TLS.supportedCiphers = TLS.ciphersuite_strong }
                }
        Left err -> ioError (userError err)

-- | Low-level TLS server helper requesting and verifying client certificates
-- against the selected roots. Applications still enforce authorization separately.
--
makeServerParams' :: FilePath       -- ^ public certificate (X.509 format).
                  -> [FilePath]     -- ^ chain certificates (X.509 format).
                  -> FilePath       -- ^ private key associated.
                  -> TrustedCAStore -- ^ server will use these certificates to validate clients.
                  -> IO TLS.ServerParams
makeServerParams' pub certs priv tca = do
    caStore <- makeCAStore tca
    p <- makeServerParams pub certs priv
    return p
        {   TLS.serverWantClientCert = True
        ,   TLS.serverShared = (TLS.serverShared p)
            {   TLS.sharedCAStore = caStore
            }
        }

-- Compatibility shims for tls < 2.1.4 vs >= 2.1.4
#if MIN_VERSION_tls(2,1,4)
defaultServerParams' :: TLS.ServerParams
defaultServerParams' = TLS.defaultParamsServer

defaultShared' :: TLS.Shared
defaultShared' = TLS.defaultShared

defaultSupported' :: TLS.Supported
defaultSupported' = TLS.defaultSupported

defaultValidationCache' :: TLS.ValidationCache
defaultValidationCache' = TLS.defaultValidationCache
#else
defaultServerParams' :: TLS.ServerParams
defaultServerParams' = def

defaultShared' :: TLS.Shared
defaultShared' = def

defaultSupported' :: TLS.Supported
defaultSupported' = def

defaultValidationCache' :: TLS.ValidationCache
defaultValidationCache' = def
#endif