content: {-# LANGUAGE TypeApplications #-}
  
  -- This file is part of the Wire Server implementation.
  --
  -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
  --
  -- This program is free software: you can redistribute it and/or modify it under
  -- the terms of the GNU Affero General Public License as published by the Free
  -- Software Foundation, either version 3 of the License, or (at your option) any
  -- later version.
  --
  -- This program is distributed in the hope that it will be useful, but WITHOUT
  -- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  -- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
  -- details.
  --
  -- You should have received a copy of the GNU Affero General Public License along
  -- with this program. If not, see <https://www.gnu.org/licenses/>.
  
  module Ssl.Util
    ( -- * Public Key Pinning
      verifyFingerprint,
  
      -- ** RSA-specific
      rsaFingerprint,
      verifyRsaFingerprint,
  
      -- * Cipher suites
      rsaCiphers,
  
      -- * Network
      withVerifiedSslConnection,
    )
  where
  
  import Control.Exception
  import Data.ByteString.Builder
  import Data.Byteable (constEqBytes)
  import Data.Dynamic (fromDynamic)
  import Data.Time.Clock (getCurrentTime)
  import Imports
  import Network.HTTP.Client.Internal
  import OpenSSL.BN (integerToMPI)
  import OpenSSL.EVP.Digest (Digest, digestLBS)
  import OpenSSL.EVP.PKey (SomePublicKey, toPublicKey)
  import OpenSSL.EVP.Verify (VerifyStatus (..))
  import OpenSSL.RSA
  import OpenSSL.Session as SSL
  import OpenSSL.X509 as X509
  
  -- Cipher Suites ------------------------------------------------------------
  
  -- | A small list of strong cipher suites for use with 'contextSetCiphers'
  -- that includes only a selected subset of those based on RSA signatures over
  -- ephemeral DH key exchanges (for perfect forward secrecy) and are thus
  -- compatible with the RSA public key pinning implemented by the functions
  -- 'rsaFingerprint' and 'verifyRsaFingerprint'.
  --
  -- As in TLS 1.3 [1], only AEAD cipher suites are included, specifically only
  -- AES-GCM and CHACHA20-POLY1305. Thereby preference is applied as follows:
  --
  --  * Elliptic curve DH variants are preferred over "classic" finite
  --    field variants for efficiency.
  --  * AES variants are preferred over ChaCha20 variants for performance,
  --    assuming AES-NI support [2].
  --  * AES-256 is preferred over AES-128 "because we can" and performance
  --    is not significantly worse, though the comparable key sizes needed for
  --    RSA and DH to achieve a comparable level of security to 256 bit
  --    symmetric keys are typically not used (see [3]).
  --
  -- This list requires on both ends of a connection either a TLS 1.2
  -- implementation that includes RFC5288 [4] (e.g. OpenSSL 1.0.1+) or a
  -- TLS 1.3 implementation that includes at least the mandatory cipher
  -- suites. For a list of OpenSSL cipher suites and how they map to TLS
  -- names, see also [5].
  --
  -- References:
  --
  -- [1] https://tlswg.github.io/tls13-spec/#rfc.appendix.A.4
  -- [2] https://calomel.org/aesni_ssl_performance.html
  -- [3] https://www.keylength.com/en/3/
  -- [4] https://tools.ietf.org/html/rfc5288#section-3
  -- [5] https://www.openssl.org/docs/manmaster/apps/ciphers.html
  rsaCiphers :: String
  rsaCiphers =
    showString "ECDHE-RSA-AES256-GCM-SHA384," -- TLS 1.3
      . showString "ECDHE-RSA-AES128-GCM-SHA256," -- TLS 1.3 (mandatory)
      . showString "ECDHE-RSA-CHACHA20-POLY1305," -- TLS 1.3
      . showString "DHE-RSA-AES256-GCM-SHA384," -- TLS 1.2 / TLS 1.3
      . showString "DHE-RSA-AES128-GCM-SHA256," -- TLS 1.2 / TLS 1.3
      . showString "DHE-RSA-CHACHA20-POLY1305" -- TLS 1.3
      $ ""
  
  -- Public Key Pinning ----------------------------------------------------
  --
  -- Overview: https://www.owasp.org/index.php/Certificate_and_Public_Key_Pinning
  
  -- | Exception thrown by 'verifyFingerprint'.
  data PinPubKeyException
    = -- | No peer certificate was found.
      PinMissingCert
    | -- | A peer certificate failed validation (e.g. signature or expiry).
      PinInvalidCert
    | -- | The peer certificate does not contain a valid public key.
      PinInvalidPubKey
    | -- | The public key fingerprint of the peer certificate
      -- did not match any of the pinned fingerprints.
      PinFingerprintMismatch
    deriving (Eq, Show)
  
  instance Exception PinPubKeyException
  
  -- | Verify the fingerprint of the public key taken from the peer certificate
  -- of the given 'SSL' connection against a list of /pinned/ fingerprints.
  --
  -- To use this function with 'opensslManagerSettingsWith'', the 'VerificationMode'
  -- must be set to 'VerifyNone'. Certificate validation is still performed by OpenSSL
  -- but the TLS handshake won't be aborted early, giving this function a chance
  -- to check for a self-signed certificate after evaluating OpenSSL's verification
  -- result using 'getVerifyResult'.
  verifyFingerprint ::
    -- | Compute the fingerprint of the peer's public key.
    (SomePublicKey -> IO (Maybe ByteString)) ->
    -- | The list of /pinned/ fingerprints.
    [ByteString] ->
    -- | The 'SSL' connection from which to obtain the peer
    -- certificate and public key.
    SSL ->
    IO ()
  verifyFingerprint hash fprs ssl = do
    cert <- SSL.getPeerCertificate ssl >>= maybe (throwIO PinMissingCert) pure
    pkey <- X509.getPublicKey cert
    mfpr <- hash pkey
    case mfpr of
      Nothing -> throwIO PinInvalidPubKey
      Just fp -> do
        unless (any (constEqBytes fp) fprs) $
          throwIO PinFingerprintMismatch
        vok <- SSL.getVerifyResult ssl
        unless vok $ do
          -- Check if the certificate is self-signed.
          self <- verifyX509 cert pkey
          unless (self == VerifySuccess) $
            throwIO PinInvalidCert
          -- For completeness, perform a date check as well.
          now <- getCurrentTime
          notBefore <- X509.getNotBefore cert
          notAfter <- X509.getNotAfter cert
          unless (now >= notBefore && now <= notAfter) $
            throwIO PinInvalidCert
  
  -- RSA ------------------------------------------------------------------------
  
  -- | Compute a simple (non-standard) fingerprint of an RSA
  -- public key for use with 'verifyRsaFingerprint' with the given
  -- 'Digest'.
  rsaFingerprint :: (RSAKey k) => Digest -> k -> IO ByteString
  rsaFingerprint d k = fmap (digestLBS d . toLazyByteString) $ do
    let s = rsaSize k
    n <- integerToMPI (rsaN k)
    e <- integerToMPI (rsaE k)
    pure $! intDec s <> byteString n <> byteString e
  
  -- | 'verifyFingerprint' specialised to 'RSAPubKey's using 'rsaFingerprint'.
  verifyRsaFingerprint :: Digest -> [ByteString] -> SSL -> IO ()
  verifyRsaFingerprint d = verifyFingerprint $ \pk ->
    case toPublicKey pk of
      Nothing -> pure Nothing
      Just k -> Just <$> rsaFingerprint d (k :: RSAPubKey)
  
  -- Note [Hostname verification]
  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- Ideally, we would like to perform proper hostname verification, which
  -- is not done automatically by OpenSSL [1]. However, the necessary APIs
  -- are not yet available via HsOpenSSL. Note though that public key pinning
  -- is already supposed to thwart attacks based on a lack of or incorrect
  -- hostname verification (see [2] for many common attacks and mistakes).
  --
  -- [1] https://wiki.openssl.org/index.php/Hostname_validation
  -- [2] https://www.cs.utexas.edu/~shmat/shmat_ccs12.pdf
  
  -- Utilities -----------------------------------------------------------------
  
  -- | Get an SSL connection that has definitely had its fingerprints checked
  -- (internally it just grabs a connection from a pool and does verification
  -- if it's a fresh one).
  --
  -- Throws an error for other types of connections.
  withVerifiedSslConnection ::
    -- | A function to verify fingerprints given an SSL connection
    (SSL -> IO ()) ->
    Manager ->
    -- | Request builder
    (Request -> Request) ->
    -- | This callback will be passed a modified
    --   request that always uses the verified
    --   connection
    (Request -> IO a) ->
    IO a
  withVerifiedSslConnection verify man reqBuilder act =
    withConnection' req man Reuse $ \mConn -> do
      -- If we see this connection for the first time, verify fingerprints
      let conn = managedResource mConn
          seen = managedReused mConn
      unless seen $ case fromDynamic @SSL (connectionRaw conn) of
        Nothing -> error ("withVerifiedSslConnection: only SSL allowed: " <> show req)
        Just ssl -> verify ssl
      -- Make a request using this connection and return it back to the
      -- pool (that's what 'Reuse' is for)
      act req {connectionOverride = Just mConn}
    where
      req = reqBuilder defaultRequest
  