TLSUtils.hs

{-# LANGUAGE OverloadedStrings #-}
module Kubernetes.Client.Internal.TLSUtils where

import Control.Exception.Safe     (Exception, MonadThrow, throwM)
import Control.Monad.IO.Class     (MonadIO, liftIO)
import Data.ByteString            (ByteString)
import Data.Default.Class         (def)
import Data.Either                (rights)
import Data.Either.Combinators    (mapLeft)
import Data.PEM                   (pemContent, pemParseBS)
import Data.X509                  (SignedCertificate, decodeSignedCertificate)
import Data.X509.CertificateStore (CertificateStore, makeCertificateStore)
import Lens.Micro                 ((&), (.~), Lens', lens, set)
import Network.TLS                (Credential, credentialLoadX509FromMemory, defaultParamsClient)
import System.X509                (getSystemCertificateStore)

import qualified Data.ByteString        as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.X509              as X509
import qualified Data.X509.Validation   as X509
import qualified Network.TLS            as TLS
import qualified Network.TLS.Extra      as TLS

-- |Default TLS settings using the system CA store.
defaultTLSClientParams :: IO TLS.ClientParams
defaultTLSClientParams = do
    let defParams = defaultParamsClient "" ""
    systemCAStore <- getSystemCertificateStore
    return defParams
        { TLS.clientSupported = def
            { TLS.supportedCiphers = TLS.ciphersuite_strong
            }
        , TLS.clientShared    = (TLS.clientShared defParams)
            { TLS.sharedCAStore = systemCAStore
            }
        }

-- |Parses a PEM-encoded @ByteString@ into a list of certificates.
parsePEMCerts :: B.ByteString -> Either ParseCertException [SignedCertificate]
parsePEMCerts pemBS = do
    pems <- pemParseBS pemBS
            & mapLeft PEMParsingFailed
    return $ rights $ map (decodeSignedCertificate . pemContent) pems

-- | Updates client params, sets CA store to passed bytestring of CA certificates
updateClientParams :: TLS.ClientParams -> ByteString -> Either ParseCertException TLS.ClientParams
updateClientParams cp certText = parsePEMCerts certText
                                 & (fmap (flip setCAStore cp))

-- |Use a custom CA store.
setCAStore :: [SignedCertificate] -> TLS.ClientParams -> TLS.ClientParams
setCAStore certs tlsParams =
  tlsParams & clientSharedL . sharedCAStoreL .~ makeCertificateStore certs

-- |Use a client cert for authentication.
setClientCert :: Credential -> TLS.ClientParams -> TLS.ClientParams
setClientCert cred = set onCertificateRequestL (\_ -> return $ Just cred)

clientHooksL :: Lens' TLS.ClientParams TLS.ClientHooks
clientHooksL = lens TLS.clientHooks (\cp ch -> cp { TLS.clientHooks = ch })

onServerCertificateL :: Lens' TLS.ClientParams (CertificateStore -> TLS.ValidationCache -> X509.ServiceID -> X509.CertificateChain -> IO [X509.FailedReason])
onServerCertificateL =
  clientHooksL . lens TLS.onServerCertificate (\ch osc -> ch { TLS.onServerCertificate = osc })

clientSharedL :: Lens' TLS.ClientParams TLS.Shared
clientSharedL = lens TLS.clientShared (\tlsParams cs -> tlsParams {TLS.clientShared = cs} )

sharedCAStoreL :: Lens' TLS.Shared CertificateStore
sharedCAStoreL = lens TLS.sharedCAStore (\shared store -> shared{TLS.sharedCAStore = store})

-- |Don't check whether the cert presented by the server matches the name of the server you are connecting to.
-- This is necessary if you specify the server host by its IP address.
disableServerNameValidation :: TLS.ClientParams -> TLS.ClientParams
disableServerNameValidation =
  set onServerCertificateL (X509.validate X509.HashSHA256 def (def { X509.checkFQHN = False }))

-- |Insecure mode. The client will not validate the server cert at all.
disableServerCertValidation :: TLS.ClientParams -> TLS.ClientParams
disableServerCertValidation = set onServerCertificateL (\_ _ _ _ -> return [])

onCertificateRequestL :: Lens' TLS.ClientParams (([TLS.CertificateType], Maybe [TLS.HashAndSignatureAlgorithm], [X509.DistinguishedName]) -> IO (Maybe (X509.CertificateChain, TLS.PrivKey)))
onCertificateRequestL =
  clientHooksL . lens TLS.onCertificateRequest (\ch ocr -> ch { TLS.onCertificateRequest = ocr })

-- |Loads certificates from a PEM-encoded file.
loadPEMCerts :: (MonadIO m, MonadThrow m) => FilePath -> m [SignedCertificate]
loadPEMCerts pemFile = do
    liftIO (B.readFile pemFile)
        >>= (either throwM return)
        .   parsePEMCerts

-- |Loads Base64 encoded certificate and private key
loadB64EncodedCert :: (MonadThrow m) => B.ByteString -> B.ByteString -> m Credential
loadB64EncodedCert certB64 keyB64 = either throwM pure $ do
  certText <- B64.decode certB64
              & mapLeft Base64ParsingFailed
  keyText <- B64.decode keyB64
              & mapLeft Base64ParsingFailed
  credentialLoadX509FromMemory certText keyText
    & mapLeft FailedToLoadCredential

data ParseCertException = PEMParsingFailed String
                        | Base64ParsingFailed String
                        | FailedToLoadCredential String
  deriving Show

instance Exception ParseCertException