{-# 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 (Int -> CertificateStoreSpec -> ShowS
[CertificateStoreSpec] -> ShowS
CertificateStoreSpec -> [Char]
(Int -> CertificateStoreSpec -> ShowS)
-> (CertificateStoreSpec -> [Char])
-> ([CertificateStoreSpec] -> ShowS)
-> Show CertificateStoreSpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CertificateStoreSpec -> ShowS
showsPrec :: Int -> CertificateStoreSpec -> ShowS
$cshow :: CertificateStoreSpec -> [Char]
show :: CertificateStoreSpec -> [Char]
$cshowList :: [CertificateStoreSpec] -> ShowS
showList :: [CertificateStoreSpec] -> ShowS
Show)

instance Semigroup CertificateStoreSpec where
  <> :: CertificateStoreSpec
-> CertificateStoreSpec -> CertificateStoreSpec
(<>) = CertificateStoreSpec
-> CertificateStoreSpec -> CertificateStoreSpec
CertStoreAppend

instance Monoid CertificateStoreSpec where
  mempty :: CertificateStoreSpec
mempty = CertificateStoreSpec
CertStoreEmpty

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

-- | Construct a certificate store with the given certificates
certStoreFromCerts :: [X509.SignedCertificate] -> CertificateStoreSpec
certStoreFromCerts :: [SignedCertificate] -> CertificateStoreSpec
certStoreFromCerts = [SignedCertificate] -> CertificateStoreSpec
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 :: [Char] -> CertificateStoreSpec
certStoreFromPath = [Char] -> CertificateStoreSpec
CertStoreFromPath

-- | Load the certificate store
loadCertificateStore :: CertificateStoreSpec -> IO X509.CertificateStore
loadCertificateStore :: CertificateStoreSpec -> IO CertificateStore
loadCertificateStore = CertificateStoreSpec -> IO CertificateStore
go
  where
    go :: CertificateStoreSpec -> IO X509.CertificateStore
    go :: CertificateStoreSpec -> IO CertificateStore
go  CertificateStoreSpec
CertStoreEmpty         = CertificateStore -> IO CertificateStore
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CertificateStore
forall a. Monoid a => a
mempty
    go (CertStoreAppend CertificateStoreSpec
c1 CertificateStoreSpec
c2) = CertificateStore -> CertificateStore -> CertificateStore
forall a. Semigroup a => a -> a -> a
(<>) (CertificateStore -> CertificateStore -> CertificateStore)
-> IO CertificateStore -> IO (CertificateStore -> CertificateStore)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CertificateStoreSpec -> IO CertificateStore
go CertificateStoreSpec
c1 IO (CertificateStore -> CertificateStore)
-> IO CertificateStore -> IO CertificateStore
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CertificateStoreSpec -> IO CertificateStore
go CertificateStoreSpec
c2
    go  CertificateStoreSpec
CertStoreFromSystem    = IO CertificateStore
X509.getSystemCertificateStore
    go (CertStoreFromCerts [SignedCertificate]
cs) = CertificateStore -> IO CertificateStore
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateStore -> IO CertificateStore)
-> CertificateStore -> IO CertificateStore
forall a b. (a -> b) -> a -> b
$ [SignedCertificate] -> CertificateStore
X509.makeCertificateStore [SignedCertificate]
cs
    go (CertStoreFromPath [Char]
fp)  = [Char] -> IO (Maybe CertificateStore)
X509.readCertificateStore [Char]
fp IO (Maybe CertificateStore)
-> (Maybe CertificateStore -> IO CertificateStore)
-> IO CertificateStore
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                   Maybe CertificateStore
Nothing -> LoadCertificateStoreException -> IO CertificateStore
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (LoadCertificateStoreException -> IO CertificateStore)
-> LoadCertificateStoreException -> IO CertificateStore
forall a b. (a -> b) -> a -> b
$ [Char] -> LoadCertificateStoreException
NoCertificatesAtPath [Char]
fp
                                   Just CertificateStore
cs -> CertificateStore -> IO CertificateStore
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CertificateStore
cs

data LoadCertificateStoreException =
    NoCertificatesAtPath FilePath
  deriving stock (Int -> LoadCertificateStoreException -> ShowS
[LoadCertificateStoreException] -> ShowS
LoadCertificateStoreException -> [Char]
(Int -> LoadCertificateStoreException -> ShowS)
-> (LoadCertificateStoreException -> [Char])
-> ([LoadCertificateStoreException] -> ShowS)
-> Show LoadCertificateStoreException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadCertificateStoreException -> ShowS
showsPrec :: Int -> LoadCertificateStoreException -> ShowS
$cshow :: LoadCertificateStoreException -> [Char]
show :: LoadCertificateStoreException -> [Char]
$cshowList :: [LoadCertificateStoreException] -> ShowS
showList :: [LoadCertificateStoreException] -> ShowS
Show)
  deriving anyclass (Show LoadCertificateStoreException
Typeable LoadCertificateStoreException
(Typeable LoadCertificateStoreException,
 Show LoadCertificateStoreException) =>
(LoadCertificateStoreException -> SomeException)
-> (SomeException -> Maybe LoadCertificateStoreException)
-> (LoadCertificateStoreException -> [Char])
-> (LoadCertificateStoreException -> Bool)
-> Exception LoadCertificateStoreException
SomeException -> Maybe LoadCertificateStoreException
LoadCertificateStoreException -> Bool
LoadCertificateStoreException -> [Char]
LoadCertificateStoreException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> (e -> Bool)
-> Exception e
$ctoException :: LoadCertificateStoreException -> SomeException
toException :: LoadCertificateStoreException -> SomeException
$cfromException :: SomeException -> Maybe LoadCertificateStoreException
fromException :: SomeException -> Maybe LoadCertificateStoreException
$cdisplayException :: LoadCertificateStoreException -> [Char]
displayException :: LoadCertificateStoreException -> [Char]
$cbacktraceDesired :: LoadCertificateStoreException -> Bool
backtraceDesired :: LoadCertificateStoreException -> Bool
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 (Int -> ServerValidation -> ShowS
[ServerValidation] -> ShowS
ServerValidation -> [Char]
(Int -> ServerValidation -> ShowS)
-> (ServerValidation -> [Char])
-> ([ServerValidation] -> ShowS)
-> Show ServerValidation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerValidation -> ShowS
showsPrec :: Int -> ServerValidation -> ShowS
$cshow :: ServerValidation -> [Char]
show :: ServerValidation -> [Char]
$cshowList :: [ServerValidation] -> ShowS
showList :: [ServerValidation] -> ShowS
Show)

validationCAStore :: ServerValidation -> IO X509.CertificateStore
validationCAStore :: ServerValidation -> IO CertificateStore
validationCAStore (ValidateServer CertificateStoreSpec
storeSpec) = CertificateStoreSpec -> IO CertificateStore
loadCertificateStore CertificateStoreSpec
storeSpec
validationCAStore ServerValidation
NoServerValidation         = CertificateStore -> IO CertificateStore
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CertificateStore
forall a. Monoid a => a
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 (Int -> SslKeyLog -> ShowS
[SslKeyLog] -> ShowS
SslKeyLog -> [Char]
(Int -> SslKeyLog -> ShowS)
-> (SslKeyLog -> [Char])
-> ([SslKeyLog] -> ShowS)
-> Show SslKeyLog
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SslKeyLog -> ShowS
showsPrec :: Int -> SslKeyLog -> ShowS
$cshow :: SslKeyLog -> [Char]
show :: SslKeyLog -> [Char]
$cshowList :: [SslKeyLog] -> ShowS
showList :: [SslKeyLog] -> ShowS
Show, SslKeyLog -> SslKeyLog -> Bool
(SslKeyLog -> SslKeyLog -> Bool)
-> (SslKeyLog -> SslKeyLog -> Bool) -> Eq SslKeyLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SslKeyLog -> SslKeyLog -> Bool
== :: SslKeyLog -> SslKeyLog -> Bool
$c/= :: SslKeyLog -> SslKeyLog -> Bool
/= :: SslKeyLog -> SslKeyLog -> Bool
Eq, (forall x. SslKeyLog -> Rep SslKeyLog x)
-> (forall x. Rep SslKeyLog x -> SslKeyLog) -> Generic SslKeyLog
forall x. Rep SslKeyLog x -> SslKeyLog
forall x. SslKeyLog -> Rep SslKeyLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SslKeyLog -> Rep SslKeyLog x
from :: forall x. SslKeyLog -> Rep SslKeyLog x
$cto :: forall x. Rep SslKeyLog x -> SslKeyLog
to :: forall x. Rep SslKeyLog x -> SslKeyLog
Generic)

instance Default SslKeyLog where
  def :: SslKeyLog
def = SslKeyLog
SslKeyLogFromEnv

keyLogger :: SslKeyLog -> IO (String -> IO ())
keyLogger :: SslKeyLog -> IO ([Char] -> IO ())
keyLogger SslKeyLog
sslKeyLog = do
    keyLogFile <- case SslKeyLog
sslKeyLog of
                    SslKeyLog
SslKeyLogNone    -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
forall a. Maybe a
Nothing
                    SslKeyLogPath [Char]
fp -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
fp
                    SslKeyLog
SslKeyLogFromEnv -> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"SSLKEYLOGFILE"
    return $
      case keyLogFile of
        Maybe [Char]
Nothing -> \[Char]
_   -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [Char]
fp -> \[Char]
str -> [Char] -> [Char] -> IO ()
appendFile [Char]
fp ([Char]
str [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")