{-# LANGUAGE NamedFieldPuns #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Optional TLS support for mutual client-server authentication on top of a Wai
-- application.

module Cardano.Wallet.Api.Server.Tls
    ( TlsConfiguration (..)
    , requireClientAuth
    ) where

import Prelude

import Data.Default
    ( Default (..) )
import Data.X509
    ( ExtKeyUsagePurpose (..), HashALG (..) )
import Data.X509.CertificateStore
    ( readCertificateStore )
import Data.X509.Validation
    ( ValidationChecks (..), ValidationHooks (..) )
import Network.TLS
    ( CertificateRejectReason (..), CertificateUsage (..), ServerHooks (..) )
import Network.Wai.Handler.WarpTLS
    ( TLSSettings (..), tlsSettingsChain )

import qualified Data.X509.Validation as X509

-- | Path to a x.509 PKI for mutual client-server authentication.
data TlsConfiguration = TlsConfiguration
    { TlsConfiguration -> FilePath
tlsCaCert :: !FilePath
    , TlsConfiguration -> FilePath
tlsSvCert :: !FilePath
    , TlsConfiguration -> FilePath
tlsSvKey  :: !FilePath
    } deriving (Int -> TlsConfiguration -> ShowS
[TlsConfiguration] -> ShowS
TlsConfiguration -> FilePath
(Int -> TlsConfiguration -> ShowS)
-> (TlsConfiguration -> FilePath)
-> ([TlsConfiguration] -> ShowS)
-> Show TlsConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TlsConfiguration] -> ShowS
$cshowList :: [TlsConfiguration] -> ShowS
show :: TlsConfiguration -> FilePath
$cshow :: TlsConfiguration -> FilePath
showsPrec :: Int -> TlsConfiguration -> ShowS
$cshowsPrec :: Int -> TlsConfiguration -> ShowS
Show)

-- Create TLS settings for a Warp Handler from the given TLS configuration.
-- These settings will expect clients to provide a valid TLS certificate during
-- handshake. To be valid, a client certificate must:
--
-- - Have been signed by the same authority (CA).
-- - Have a 'Key Usage Purpose' set to 'Client'
requireClientAuth
    :: TlsConfiguration
    -> TLSSettings
requireClientAuth :: TlsConfiguration -> TLSSettings
requireClientAuth TlsConfiguration{FilePath
tlsCaCert :: FilePath
tlsCaCert :: TlsConfiguration -> FilePath
tlsCaCert,FilePath
tlsSvCert :: FilePath
tlsSvCert :: TlsConfiguration -> FilePath
tlsSvCert,FilePath
tlsSvKey :: FilePath
tlsSvKey :: TlsConfiguration -> FilePath
tlsSvKey} = TLSSettings
tlsSettings
    { tlsWantClientCert :: Bool
tlsWantClientCert = Bool
True
    , tlsServerHooks :: ServerHooks
tlsServerHooks = ServerHooks
forall a. Default a => a
def
        { onClientCertificate :: CertificateChain -> IO CertificateUsage
onClientCertificate =
            (Maybe FilePath -> CertificateUsage)
-> IO (Maybe FilePath) -> IO CertificateUsage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe FilePath -> CertificateUsage
certificateUsageFromValidations (IO (Maybe FilePath) -> IO CertificateUsage)
-> (CertificateChain -> IO (Maybe FilePath))
-> CertificateChain
-> IO CertificateUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificateChain -> IO (Maybe FilePath)
validateCertificate
        }
    }
  where
    tlsSettings :: TLSSettings
tlsSettings =
        FilePath -> [FilePath] -> FilePath -> TLSSettings
tlsSettingsChain FilePath
tlsSvCert [FilePath
tlsCaCert] FilePath
tlsSvKey

    -- NOTE
    -- This checks makes sense only for remote services, to validate that the
    -- fully qualified hostname from the certificate matches the one from the
    -- service we're trying to reach. This is of little use for a server
    -- validation.
    serviceID :: (FilePath, ByteString)
serviceID =
        (FilePath
"", ByteString
"")

    certificateUsageFromValidations :: Maybe FilePath -> CertificateUsage
certificateUsageFromValidations =
        CertificateUsage
-> (FilePath -> CertificateUsage)
-> Maybe FilePath
-> CertificateUsage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CertificateUsage
CertificateUsageAccept (CertificateRejectReason -> CertificateUsage
CertificateUsageReject (CertificateRejectReason -> CertificateUsage)
-> (FilePath -> CertificateRejectReason)
-> FilePath
-> CertificateUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CertificateRejectReason
CertificateRejectOther)

    -- By default, X509.Validation validates the certificate names against the host
    -- which is irrelevant when checking the client certificate (but relevant for
    -- the client when checking the server's certificate).
    hooks :: ValidationHooks
hooks = ValidationHooks
forall a. Default a => a
def
        { hookValidateName :: FilePath -> Certificate -> [FailedReason]
hookValidateName = \FilePath
_ Certificate
_ -> [] }

    -- Here we add extra checks as the ones performed by default to enforce that
    -- the client certificate is actually _meant_ to be used for client auth.
    -- This should prevent server certificates to be used to authenticate
    -- against the server.
    checks :: ValidationChecks
checks = ValidationChecks
forall a. Default a => a
def
        { checkStrictOrdering :: Bool
checkStrictOrdering = Bool
True
        , checkLeafKeyPurpose :: [ExtKeyUsagePurpose]
checkLeafKeyPurpose = [ExtKeyUsagePurpose
KeyUsagePurpose_ClientAuth]
        }

    -- This solely verify that the provided certificate is valid and was signed by authority we
    -- recognize (tpCaPath)
    validateCertificate :: CertificateChain -> IO (Maybe FilePath)
validateCertificate CertificateChain
cert = do
        Maybe CertificateStore
mstore <- FilePath -> IO (Maybe CertificateStore)
readCertificateStore FilePath
tlsCaCert
        IO (Maybe FilePath)
-> (CertificateStore -> IO (Maybe FilePath))
-> Maybe CertificateStore
-> IO (Maybe FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"Cannot init a store, unable to validate client certificates")
            (([FailedReason] -> Maybe FilePath)
-> IO [FailedReason] -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FailedReason] -> Maybe FilePath
forall a. Show a => [a] -> Maybe FilePath
fromX509FailedReasons (IO [FailedReason] -> IO (Maybe FilePath))
-> (CertificateStore -> IO [FailedReason])
-> CertificateStore
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificateStore -> IO [FailedReason]
validateStore)
            Maybe CertificateStore
mstore
      where
        validateStore :: CertificateStore -> IO [FailedReason]
validateStore CertificateStore
store =
            HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> (FilePath, ByteString)
-> CertificateChain
-> IO [FailedReason]
X509.validate HashALG
HashSHA256 ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ValidationCache
forall a. Default a => a
def (FilePath, ByteString)
serviceID CertificateChain
cert

    fromX509FailedReasons :: [a] -> Maybe FilePath
fromX509FailedReasons [a]
reasons =
        case [a]
reasons of
            [] -> Maybe FilePath
forall a. Maybe a
Nothing
            [a]
_  -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ([a] -> FilePath
forall a. Show a => a -> FilePath
show [a]
reasons)