TLS.hs

{-# LANGUAGE OverloadedStrings #-}

-- | TLS utilities
--
-- Intended for qualified import.
--
-- > import Network.GRPC.Util.TLS (ServerValidation(..))
-- > import Network.GRPC.Util.TLS qualified as Util.TLS
module Network.GRPC.Util.TLS (
    -- * Certificate store
    CertificateStoreSpec(..)
  , certStoreFromSystem
  , certStoreFromCerts
  , certStoreFromPath
  , loadCertificateStore
    -- * Configuration
    -- ** Parameters
  , ServerValidation(..)
  , validationCAStore
    -- ** Common to server and client
  , SslKeyLog(..)
  , keyLogger
  ) where

import Control.Exception
import Data.Default
import Data.X509 qualified as X509
import Data.X509.CertificateStore qualified as X509
import GHC.Generics (Generic)
import System.Environment
import System.X509 qualified as X509

{-------------------------------------------------------------------------------
  Certificate store
-------------------------------------------------------------------------------}

-- | Certificate store specification (for certificate validation)
--
-- This is a deep embedding, describing how to construct a certificate store.
-- The actual construction happens in 'loadCertificateStore'.
--
-- There are three primitive ways to construct a 'CertificateStore':
-- 'certStoreFromSystem', 'certStoreFromCerts', and 'certStoreFromPath'; please
-- refer to the corresponding documentation.
--
-- You can also combine 'CertificateStore's through the 'Monoid' instance.
data CertificateStoreSpec =
    CertStoreEmpty
  | CertStoreAppend CertificateStoreSpec CertificateStoreSpec
  | CertStoreFromSystem
  | CertStoreFromCerts [X509.SignedCertificate]
  | CertStoreFromPath FilePath
  deriving (Show)

instance Semigroup CertificateStoreSpec where
  (<>) = CertStoreAppend

instance Monoid CertificateStoreSpec where
  mempty = CertStoreEmpty

-- | Use the system's certificate store
certStoreFromSystem :: CertificateStoreSpec
certStoreFromSystem = CertStoreFromSystem

-- | Construct a certificate store with the given certificates
certStoreFromCerts :: [X509.SignedCertificate] -> CertificateStoreSpec
certStoreFromCerts = CertStoreFromCerts

-- | Load certificate store from disk
--
-- The path may point to single file (multiple PEM formatted certificates
-- concanated) or directory (one certificate per file, file names are hashes
-- from certificate).
certStoreFromPath :: FilePath -> CertificateStoreSpec
certStoreFromPath = CertStoreFromPath

-- | Load the certificate store
loadCertificateStore :: CertificateStoreSpec -> IO X509.CertificateStore
loadCertificateStore = go
  where
    go :: CertificateStoreSpec -> IO X509.CertificateStore
    go  CertStoreEmpty         = return mempty
    go (CertStoreAppend c1 c2) = (<>) <$> go c1 <*> go c2
    go  CertStoreFromSystem    = X509.getSystemCertificateStore
    go (CertStoreFromCerts cs) = return $ X509.makeCertificateStore cs
    go (CertStoreFromPath fp)  = X509.readCertificateStore fp >>= \case
                                   Nothing -> throwIO $ NoCertificatesAtPath fp
                                   Just cs -> return cs

data LoadCertificateStoreException =
    NoCertificatesAtPath FilePath
  deriving stock (Show)
  deriving anyclass (Exception)

{-------------------------------------------------------------------------------
  Parameters
-------------------------------------------------------------------------------}

-- | How does the client want to validate the server?
data ServerValidation =
    -- | Validate the server
    --
    -- The 'CertificateStore' is a collection of trust anchors. If 'Nothing'
    -- is specified, the system certificate store will be used.
    ValidateServer CertificateStoreSpec

    -- | Skip server validation
    --
    -- WARNING: This is dangerous. Although communication with the server will
    -- still be encrypted, you cannot be sure that the server is who they claim
    -- to be.
  | NoServerValidation
  deriving (Show)

validationCAStore :: ServerValidation -> IO X509.CertificateStore
validationCAStore (ValidateServer storeSpec) = loadCertificateStore storeSpec
validationCAStore NoServerValidation         = return mempty

{-------------------------------------------------------------------------------
  Configuration common to server and client
-------------------------------------------------------------------------------}

-- | SSL key log file
--
-- An SSL key log file can be used by tools such as Wireshark to decode TLS
-- network traffic. It is used for debugging only.
data SslKeyLog =
    -- | Don't use a key log file
    SslKeyLogNone

    -- | Use the specified path
  | SslKeyLogPath FilePath

    -- | Use the @SSLKEYLOGFILE@ environment variable to determine the key log
    --
    -- This is the default.
  | SslKeyLogFromEnv
  deriving stock (Show, Eq, Generic)

instance Default SslKeyLog where
  def = SslKeyLogFromEnv

keyLogger :: SslKeyLog -> IO (String -> IO ())
keyLogger sslKeyLog = do
    keyLogFile <- case sslKeyLog of
                    SslKeyLogNone    -> return $ Nothing
                    SslKeyLogPath fp -> return $ Just fp
                    SslKeyLogFromEnv -> lookupEnv "SSLKEYLOGFILE"
    return $
      case keyLogFile of
        Nothing -> \_   -> return ()
        Just fp -> \str -> appendFile fp (str ++ "\n")